Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/getrea1a/form1.frm

Text File | 1999-07-07 | 6KB | 194 lines

VERSION 5.00
Begin VB.Form Form1
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Size Check"
   ClientHeight    =   5088
   ClientLeft      =   36
   ClientTop       =   324
   ClientWidth     =   4188
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   5088
   ScaleWidth      =   4188
   StartUpPosition =   3  'Windows Default
   Begin VB.ComboBox cboFileSistem
      Height          =   288
      ItemData        =   "Form1.frx":0000
      Left            =   120
      List            =   "Form1.frx":000A
      Style           =   2  'Dropdown List
      TabIndex        =   6
      Top             =   3480
      Width           =   3972
   End
   Begin VB.Frame Frame1
      Height          =   3252
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   3972
      Begin VB.CommandButton cmdCheckFile
         Caption         =   "Check File Size"
         Height          =   372
         Left            =   1920
         TabIndex        =   5
         Top             =   2760
         Width           =   1932
      End
      Begin VB.CommandButton cmdCheckFolder
         Caption         =   "Check Folder Size"
         Height          =   372
         Left            =   1920
         TabIndex        =   4
         Top             =   2280
         Width           =   1932
      End
      Begin VB.DirListBox Dir1
         Height          =   2232
         Left            =   120
         TabIndex        =   3
         Top             =   240
         Width           =   1572
      End
      Begin VB.DriveListBox Drive1
         Height          =   288
         Left            =   120
         TabIndex        =   2
         Top             =   2640
         Width           =   1572
      End
      Begin VB.FileListBox File1
         Height          =   1800
         Left            =   1920
         TabIndex        =   1
         Top             =   240
         Width           =   1932
      End
   End
   Begin VB.Label lblResult
      Alignment       =   2  'Center
      Height          =   972
      Left            =   120
      TabIndex        =   7
      Top             =   3960
      Width           =   3972
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim ClasterSize As Integer
Dim fs As New FileSystemObject
Dim FolderSize
Dim ActFolderSize
Private Sub cboFileSistem_Click()
Select Case cboFileSistem
   Case "FAT16"
    ClasterSize = 16
   Case "FAT32"
    ClasterSize = 4
End Select
End Sub

Private Sub cmdCheckFile_Click()
Dim FilePath As String
Dim S As Double
Dim ActSize As Double
If Right(Dir1.Path, 1) <> "\" Then
   FilePath = Dir1.Path & "\" & File1.FileName
  Else
   FilePath = Dir1.Path & File1.FileName
End If
S = GetFileSize(FilePath)
If S <> 0 Then S = S / 1024
ActSize = GetActualFileSize(FilePath)
Call ShowResult(FilePath, S, ActSize, " Kb ")
End Sub

Private Sub cmdCheckFolder_Click()
Screen.MousePointer = 11
Form1.Enabled = False
DoFolder Dir1.Path
Call ShowResult(Dir1.Path, FolderSize / 1024, ActFolderSize, " Mb ")
FolderSize = 0
ActFolderSize = 0
Form1.Enabled = True
Screen.MousePointer = 1
End Sub

Private Sub Drive1_Change()
   Dir1.Path = Drive1.Drive   ' When drive changes, set directory path.
End Sub
Private Sub Dir1_Change()
   File1.Path = Dir1.Path   ' When directory changes, set file path.
End Sub



Private Sub File1_DblClick()
cmdCheckFile_Click
End Sub

Private Sub Form_Load()
cboFileSistem.ListIndex = 0
End Sub
' This function returns lenght of file in bytes
Public Function GetFileSize(Path As String) As Long
On Error Resume Next
GetFileSize = FileLen(Path)
On Error GoTo 0
End Function
'This function returns the space that file  file is cathing on drive in Kb
Public Function GetActualFileSize(FilePath As String) As Long
Dim Size
On Error Resume Next
Size = GetFileSize(FilePath)
'If size=0 exit function
If Size = 0 Then
   GetActualFileSize = 0
   Exit Function
End If
Size = Size / 1024 'Get size in Kb
If Size < ClasterSize Then
   GetActualFileSize = ClasterSize
   Exit Function
End If
If Size / ClasterSize = Size \ ClasterSize Then
   GetActualFileSize = Size
  Else
   GetActualFileSize = (Size \ ClasterSize + 1) * ClasterSize
End If
End Function

Public Sub ShowResult(Name As String, Size As Double, ByVal ActualeSize As Double, Units As String)
Dim Message As String
Message = " File Name    : " & Name & vbCrLf & _
          " Size         : " & Format(Size, "#0.00") & Units & vbCrLf & _
          " Actuale Size : " & Format(ActualeSize, "#0.00") & Units
lblResult.Caption = Message
End Sub

'This function puts in FolderSize size of folder in Kb
'and in ActFolderSize : size on drive in Mb
Public Sub DoFolder(Path As String)
Dim fol As Folder
Dim fi As Folder
Dim fols As Folders
Dim fils As Files
Dim fil As File
Set fol = fs.GetFolder(Path)
Set fils = fol.Files
 For Each fil In fils
   FolderSize = FolderSize + GetFileSize(fil.Path) / 1024
   ActFolderSize = ActFolderSize + GetActualFileSize(fil.Path) / 1024
 Next fil
Set fols = fol.SubFolders
For Each fi In fols
'Recurcive call for next subfolder
 DoFolder fi.Path
Next fi
End Sub